home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / EDINIT.S < prev    next >
Encoding:
Text File  |  1993-10-03  |  3.4 KB  |  106 lines
  1. ;;;
  2. ;;; Export EDWIN and EDWIN-RESET-WINDOWS to user-global-environment
  3. ;;;
  4.  
  5. (set! (access edwin user-global-environment) edwin)
  6. (set! (access edwin-reset-windows user-global-environment)
  7.       (access edwin-reset-windows edwin-environment))
  8.  
  9. ;;;
  10. ;;; Export function which can remove edwin and reclaim all space
  11. ;;;
  12.  
  13. (set! (access remove-edwin user-global-environment)
  14.   (lambda ()
  15.     ;;;
  16.     ;;; Remove macros so there are no ties to EDWIN-ENVIRONMENT
  17.     ;;;
  18.     (remprop '%after 'PCS*MACRO)
  19.     (remprop '%before 'PCS*MACRO)
  20.     (remprop '%in? 'PCS*MACRO)
  21.     (remprop '%in-out-flag 'PCS*MACRO)
  22.     (remprop '%next 'PCS*MACRO)
  23.     (remprop '%set-next 'PCS*MACRO)
  24.     (remprop 'current-point 'PCS*PRIMOP-HANDLER)
  25.     (remprop 'define-initial-command-key 'PCS*MACRO)
  26.     (remprop 'extended-char 'PCS*PRIMOP-HANDLER)
  27.     (remprop 'make-new-state 'PCS*MACRO)
  28.     (remprop 'remap-edwin-key 'PCS*MACRO)
  29.     (remprop 'string-allocate 'PCS*MACRO)
  30.     ;;;
  31.     ;;; Unbind REMOVE-EDWIN and EDWIN-ENVIRONMENT
  32.     ;;; 
  33.     (unbind 'edwin-reset-windows user-global-environment)
  34.     (unbind 'edwin-environment user-global-environment)
  35.     (unbind 'remove-edwin user-global-environment)
  36.     ;;;
  37.     ;;; Set EXIT and EDWIN definitions back to original
  38.     ;;;
  39.     (set! (access exit user-global-environment)
  40.       (access system-exit user-global-environment))
  41.  
  42.     (set! (access edwin user-global-environment)
  43.       (access initiate-edwin user-global-environment))
  44.     (unbind 'system-exit user-global-environment)
  45.     *the-non-printing-object*
  46.   ))
  47.  
  48. (set! (access system-exit user-global-environment) 
  49.       (access exit user-global-environment))
  50.  
  51. (define %edwin-buffer%
  52.   (lambda ()
  53.        (vector-ref (vector-ref edwin-editor 1) 7)))
  54.  
  55. (define edwin-buffer-modified?
  56.   (lambda (buf)
  57.     (vector-ref buf 5)))
  58.  
  59. (define exit
  60.   (lambda args
  61.     (cond ((or (unbound? edwin-editor)
  62.            (unassigned? edwin-editor))
  63.            (apply system-exit args))
  64.           (else
  65.            (%save-buffer-changes (%edwin-buffer%))
  66.            (if (edwin-buffer-modified? (%edwin-buffer%))
  67.              (if (prompt-for-confirmation? "Exit anyway (Y or N)?")
  68.                (apply system-exit args))
  69.              (apply system-exit args))
  70.            (gc)))))
  71.  
  72. (set! (access exit user-global-environment) exit)
  73.  
  74. (macro remap-edwin-key
  75.   (lambda (e)
  76.      `(set-edwin-key  ,(cadr e) (comtab-entry ,(caddr e)))))
  77.  
  78. (define set-edwin-key
  79.   (letrec
  80.     ((%prefix
  81.        (lambda (alists char)
  82.          (%set-comtab-entry! alists char %command)))
  83.      (%command '()))
  84.  
  85.     (lambda (char command)
  86.       (cond ((char? char)
  87.              (%set-comtab-key comtab (char-upcase char) command)
  88.              (if (char-alphabetic?  char)
  89.                  (%set-comtab-key comtab (char-downcase char) command)))
  90.             ((and (pair? char) (null? (cdr char)))
  91.              (%set-comtab-key comtab (char-upcase (car char)) command)
  92.              (if (char-alphabetic?  (car char))
  93.                  (%set-comtab-key comtab (char-downcase (car char)) command)))
  94.             ((pair? char)
  95.              (set! %command command)
  96.              (comtab-lookup-prefix char %prefix))
  97.         ((char-set? char)
  98.          (mapc (lambda (char) (set-comtab-entry! char command))
  99.            (char-set-members char)))
  100.         (else (error "Unknown character" char)))
  101.       char)))
  102.  
  103. (let ((edwin-init (%system-file-name "EDWIN.INI")))
  104.   (if (file-exists? edwin-init)
  105.       (load edwin-init)))
  106.